unit uDZHttpTypes;

interface

uses
  SysUtils;

const
  PORT_HTTP = 80;
  PORT_HTTPS = 443;
  PORT_FTP = 21;
  PORT_GOPHER = 70;

type
  TUrlScheme = (usPartial, usUnknow, usDefault, usFtp{1}, usGopher{2}, usHttp{3},
    usHttps, usFile, usNews, usMailto);

const
  DefaultInternetPorts: array [TUrlScheme] of Integer =
    (0, 0, 0, PORT_FTP, PORT_GOPHER, PORT_HTTP, PORT_HTTPS, 0, 0, 0);

type
  TDzUrlComponents = object
  public
    Scheme: TUrlScheme;
    HostPtr: PAnsiChar;
    HostLen: Integer;
    Port: Integer;
    UserNamePtr: PAnsiChar;
    UserNameLen: Integer;
    PasswordPtr: PAnsiChar;
    PasswordLen: Integer;
    PathPtr: PAnsiChar;
    PathLen: Integer;
    ParamsPtr: PAnsiChar;
    ParamsLen: Integer;
  public
    function Host: AnsiString;
    function Path: AnsiString;
    function Params: AnsiString;
    function PathWithParams: AnsiString;
    function UserName: AnsiString;
    function Password: AnsiString;
  end;
  PURL = ^TDzUrlComponents;

  EDzInvalidUrl = class(Exception);

function ParseUrl(const Url: AnsiString; out Components: TDzUrlComponents): Boolean;

implementation

type
  TUrlPart = (upUnknown, upSchema, upUserName, upHost, upPort, upPath, upParam);

  TUrlColon = record
    case Part: TUrlPart of
      upUserName: (
        UserNamePtr: PAnsiChar;
        UserNameLen: Integer;
        PasswordPtr: PAnsiChar;
        PasswordLen: Integer);
      upPort: (Port: Integer; PortPtr: PAnsiChar; PortLen: Integer)
  end;

function ParseScheme(Str: PAnsiChar; Len: Integer): TUrlScheme;
begin
  Result := usUnknow;
  if Len = 3 then
  begin
    if (Str[0] in ['F', 'f']) and (Str[1] in ['T', 't']) and (Str[2] in ['P', 'p']) then
      Result := usFtp;
    Exit;
  end;

  if Len = 4 then
  begin
    case Str[0] of
      'H', 'h': if (Str[1] in ['T', 't']) and (Str[2] in ['T', 't']) and
        (Str[3] in ['P', 'p']) then Result := usHttp;
      'F', 'f': if (Str[1] in ['I', 'i']) and (Str[2] in ['F', 'f']) and
        (Str[3] in ['L', 'l']) then Result := usFile;
      'N', 'n': if (Str[1] in ['E', 'e']) and (Str[2] in ['W', 'w']) and
        (Str[3] in ['S', 's']) then Result := usNews;
    end;
    Exit;
  end;

  if Len = 5 then
  begin
    if (Str[0] in ['H', 'h']) and (Str[1] in ['T', 't']) and (Str[2] in ['T', 't']) and
      (Str[3] in ['P', 'p']) and (Str[4] in ['S', 's']) then Result := usHttps;
    Exit;
  end;

  if Len = 6 then
  begin
    case Str[0] of
      'G', 'g': if (Str[1] in ['O', 'o']) and (Str[2] in ['P', 'p']) and
        (Str[3] in ['H', 'h']) and (Str[4] in ['E', 'e']) and
        (Str[5] in ['R', 'r']) then Result := usGopher;
      'M', 'm': if (Str[1] in ['A', 'a']) and (Str[2] in ['I', 'i']) and
        (Str[3] in ['L', 'l']) and (Str[4] in ['T', 't']) and
        (Str[5] in ['O', 'o']) then Result := usMailto;
    end;
  end;
end;

function UrlParseColon(BeginChar, Colon, EndChar: PAnsiChar;
  out Output: TUrlColon): Boolean;
var
  Ptr: PAnsiChar;
  Flag: Boolean;
  Port: Integer;
begin
  Result := True;
  Ptr := Colon + 1;
  Flag := True;
  Port := 0;
  while Ptr < EndChar do
  begin
    case Ptr^ of
      '/': Break;
      '@':
        begin
          Output.Part := upUserName;
          Output.UserNamePtr := BeginChar;
          Output.UserNameLen := Colon - BeginChar;
          Output.PasswordPtr := Colon + 1;
          Output.PasswordLen := Ptr - Colon - 1;
          Exit;
        end;
      '0'..'9':
        begin
          if Flag then
          begin
            Port := Port * 10 + Byte(Ptr^) and $0f;
          end;
        end;
      else begin
        Flag := False;
      end;
    end;
    Inc(Ptr);
  end;
  if not Flag then
  begin
    Result := False;
    Exit;
  end;
  Output.Part := upPort;
  Output.Port := Port;
  Output.PortPtr := Colon + 1;
  Output.PortLen := Ptr - Colon - 1;
end;

function ParseUrl(const Url: AnsiString; out Components: TDzUrlComponents): Boolean;
var
  pUrl, CharPtr, UrlEnd: PAnsiChar;
  UrlColon: TUrlColon;
  State: TUrlPart;
begin
  pUrl := PAnsiChar(Url);
  UrlEnd := pUrl + Length(Url);
  CharPtr := pUrl;
  State := upPath;
  FillChar(Components, SizeOf(Components), 0);
  Result := True;
  while (CharPtr < UrlEnd) and not (CharPtr^ in [':', '.', '/', '@']) do Inc(CharPtr);
  if CharPtr = UrlEnd then
  begin
    Components.Scheme := usHttp;
    Components.HostPtr := pUrl;
    Components.HostLen := CharPtr - pUrl;
    Components.Port := PORT_HTTP;
    Components.PathPtr := '/';
    Components.PathLen := 1;
    Exit;
  end;
  case CharPtr^ of
    ':':
      begin
        if CharPtr = UrlEnd - 1 then
        begin
          Result := False;
          Exit;
        end;
        if CharPtr[1] = '/' then
        begin
          //scheme
          if (CharPtr = UrlEnd - 2) or (CharPtr[2] <> '/') then
          begin
            Result := False;
            Exit;
          end;
          Components.Scheme := ParseScheme(pUrl, CharPtr - pUrl);
          if Components.Scheme = usUnknow then Exit;
          Inc(CharPtr, 3);
          State := upUserName;  //scheme get, username&password expected
        end
        else begin
          //host&port or username&password
          Components.Scheme := usHttp;
          if not UrlParseColon(pUrl, CharPtr, UrlEnd, UrlColon) then
          begin
            Result := False;
            Exit;
          end;
          if UrlColon.Part = upUserName then
          begin
            Components.UserNamePtr := UrlColon.UserNamePtr;
            Components.UserNameLen := UrlColon.UserNameLen;
            Components.PasswordPtr := UrlColon.PasswordPtr;
            Components.PasswordLen := UrlColon.PasswordLen;
            State := upHost; //username&password get, host expected
            CharPtr := UrlColon.PasswordPtr + UrlColon.PasswordLen + 1;
          end
          else begin
            Components.HostPtr := pUrl;
            Components.HostLen := CharPtr - pUrl;
            Components.Port := UrlColon.Port;
            CharPtr := UrlColon.PortPtr + UrlColon.PortLen;
            //State := 2; //host&port get, path expected
          end;
        end;
      end;
    '.':
      begin
        Components.Scheme := usHttp;
        while (CharPtr < UrlEnd) and not (CharPtr^ in [':', '/']) do Inc(CharPtr);
        if (CharPtr = UrlEnd) or (CharPtr^ = '/') then
        begin
          Components.Port := PORT_HTTP;
          Components.HostPtr := pUrl;
          Components.HostLen := CharPtr - pUrl;
          if CharPtr = UrlEnd then
          begin
            Components.PathPtr := '/';
            Components.PathLen := 1;
            Exit;
          end;
        end;
        if CharPtr^ = ':' then
        begin
          if not UrlParseColon(pUrl, CharPtr, UrlEnd, UrlColon) then
          begin
            Result := False;
            Exit;
          end;
          if UrlColon.Part = upUserName then
          begin
            Components.UserNamePtr := UrlColon.UserNamePtr;
            Components.UserNameLen := UrlColon.UserNameLen;
            Components.PasswordPtr := UrlColon.PasswordPtr;
            Components.PasswordLen := UrlColon.PasswordLen;
            State := upHost; //username&password get, host expected
            CharPtr := UrlColon.PasswordPtr + UrlColon.PasswordLen + 1;
          end
          else begin
            Components.HostPtr := pUrl;
            Components.HostLen := CharPtr - pUrl;
            Components.Port := UrlColon.Port;
            CharPtr := UrlColon.PortPtr + UrlColon.PortLen;
            //State := 2; //host&port get, path expected
          end;
        end;
      end;
    '/':
      begin
        Components.Scheme := usHttp;
        Components.Port := PORT_HTTP;
        Components.HostPtr := pUrl;
        Components.HostLen := CharPtr - pUrl; 
      end;
    '@':
      begin
        Components.Scheme := usHttp;
        Components.UserNamePtr := pUrl;
        Components.UserNameLen := CharPtr - pUrl;
        Inc(CharPtr);
        State := upHost;
      end;
  end;

  pUrl := CharPtr;
  if State = upUserName then
  begin
    while (CharPtr < UrlEnd) and not (CharPtr^ in [':', '/', '@']) do Inc(CharPtr);
    if CharPtr = UrlEnd then
    begin
      Components.HostPtr := pUrl;
      Components.HostLen := CharPtr - pUrl;
      Components.Port := DefaultInternetPorts[Components.Scheme];
      Components.PathPtr := '/';
      Components.PathLen := 1;
      Exit;
    end;

    case CharPtr^ of
      ':':
        begin
          if not UrlParseColon(pUrl, CharPtr, UrlEnd, UrlColon) then
          begin
            Result := False;
            Exit;
          end;
          if UrlColon.Part = upUserName then
          begin
            Components.UserNamePtr := UrlColon.UserNamePtr;
            Components.UserNameLen := UrlColon.UserNameLen;
            Components.PasswordPtr := UrlColon.PasswordPtr;
            Components.PasswordLen := UrlColon.PasswordLen;
            State := upHost; //username&password get, host expected
            CharPtr := UrlColon.PasswordPtr + UrlColon.PasswordLen + 1;
          end
          else begin
            Components.HostPtr := pUrl;
            Components.HostLen := CharPtr - pUrl;
            Components.Port := UrlColon.Port;
            CharPtr := UrlColon.PortPtr + UrlColon.PortLen;
            State := upPath; //host&port get, path expected
          end;
        end;
      '@':
        begin
          Components.UserNamePtr := pUrl;
          Components.UserNameLen := CharPtr - pUrl;
          Inc(CharPtr);
          State := upHost;
        end;
      else begin
        Components.HostPtr := pUrl;
        Components.HostLen := CharPtr - pUrl;
        Components.Port := DefaultInternetPorts[Components.Scheme];
        State := upPath;
      end;
    end;
  end;

  pUrl := CharPtr;
  if State = upHost then
  begin
    while (CharPtr < UrlEnd) and not (CharPtr^ in [':', '/']) do Inc(CharPtr);
    Components.HostPtr := pUrl;
    Components.HostLen := CharPtr - pUrl;
    if CharPtr = UrlEnd then
    begin
      Components.Port := DefaultInternetPorts[Components.Scheme];
      Components.PathPtr := '/';
      Components.PathLen := 1;
      Exit;
    end;
    if CharPtr^ = ':' then
    begin
      Inc(CharPtr);
      while CharPtr < UrlEnd do
      begin
        if CharPtr^ = '/' then
        begin
          if Components.Port = 0 then
          begin
            Result := False; Exit;
          end;
          Break;
        end;
        if not (CharPtr^ in ['0'..'9']) then
        begin
          Result := False;
          Exit;
        end;
        Components.Port := Components.Port * 10 + Byte(CharPtr^) and $0f;
        Inc(CharPtr);
      end;
    end
    else begin
      Components.Port := DefaultInternetPorts[Components.Scheme];
    end;
  end;

  pUrl := CharPtr;
  while (CharPtr < UrlEnd)  and (CharPtr^ <> '?') do Inc(CharPtr);
  Components.PathPtr := pUrl;
  Components.PathLen := CharPtr - pUrl;
  if CharPtr < UrlEnd then
  begin
    Components.ParamsPtr := CharPtr;
    Components.ParamsLen := UrlEnd - CharPtr;
  end;
end;

function AnsiStrFromBuf(Buf: Pointer; BufLen: Integer): AnsiString;
begin
  SetLength(Result, BufLen);
  if BufLen = 0 then Exit;
  Move(Buf^, Pointer(Result)^, BufLen);
end;

{ TDzUrlComponents }

function TDzUrlComponents.Host: AnsiString;
begin
  Result := AnsiStrFromBuf(HostPtr, HostLen);
end;

function TDzUrlComponents.Params: AnsiString;
begin
  Result := AnsiStrFromBuf(ParamsPtr, ParamsLen);
end;

function TDzUrlComponents.Password: AnsiString;
begin
  Result := AnsiStrFromBuf(PasswordPtr, PasswordLen);
end;

function TDzUrlComponents.Path: AnsiString;
begin
  Result := AnsiStrFromBuf(PathPtr, PathLen);
end;

function TDzUrlComponents.PathWithParams: AnsiString;
begin
  Result := AnsiStrFromBuf(PathPtr, PathLen + ParamsLen);
end;

function TDzUrlComponents.UserName: AnsiString;
begin
  Result := AnsiStrFromBuf(UserNamePtr, UserNameLen);
end;

end.
